home *** CD-ROM | disk | FTP | other *** search
/ HAKERIS 11 / HAKERIS 11.ISO / linux / system / LinuxConsole 0.4 / linuxconsole0.4install-en.iso / guile0.4.lcm / share / guile / 1.6.0 / ice-9 / emacs.scm < prev    next >
Encoding:
Text File  |  2004-01-06  |  8.9 KB  |  297 lines
  1. ;;;;     Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001 Free Software Foundation, Inc.
  2. ;;;; 
  3. ;;;; This program is free software; you can redistribute it and/or modify
  4. ;;;; it under the terms of the GNU General Public License as published by
  5. ;;;; the Free Software Foundation; either version 2, or (at your option)
  6. ;;;; any later version.
  7. ;;;; 
  8. ;;;; This program is distributed in the hope that it will be useful,
  9. ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11. ;;;; GNU General Public License for more details.
  12. ;;;; 
  13. ;;;; You should have received a copy of the GNU General Public License
  14. ;;;; along with this software; see the file COPYING.  If not, write to
  15. ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  16. ;;;; Boston, MA 02111-1307 USA
  17. ;;;;
  18. ;;;; As a special exception, the Free Software Foundation gives permission
  19. ;;;; for additional uses of the text contained in its release of GUILE.
  20. ;;;;
  21. ;;;; The exception is that, if you link the GUILE library with other files
  22. ;;;; to produce an executable, this does not by itself cause the
  23. ;;;; resulting executable to be covered by the GNU General Public License.
  24. ;;;; Your use of that executable is in no way restricted on account of
  25. ;;;; linking the GUILE library code into it.
  26. ;;;;
  27. ;;;; This exception does not however invalidate any other reasons why
  28. ;;;; the executable file might be covered by the GNU General Public License.
  29. ;;;;
  30. ;;;; This exception applies only to the code released by the
  31. ;;;; Free Software Foundation under the name GUILE.  If you copy
  32. ;;;; code from other Free Software Foundation releases into a copy of
  33. ;;;; GUILE, as the General Public License permits, the exception does
  34. ;;;; not apply to the code that you add in this way.  To avoid misleading
  35. ;;;; anyone as to the status of such modified files, you must delete
  36. ;;;; this exception notice from them.
  37. ;;;;
  38. ;;;; If you write modifications of your own for GUILE, it is your choice
  39. ;;;; whether to permit this exception to apply to your modifications.
  40. ;;;; If you do not wish that, delete this exception notice.
  41. ;;;;
  42. ;;;; The author can be reached at djurfeldt@nada.kth.se
  43. ;;;; Mikael Djurfeldt, SANS/NADA KTH, 10044 STOCKHOLM, SWEDEN
  44. ;;;; (I didn't write this!)
  45. ;;;;
  46.  
  47.  
  48. ;;; *********************************************************************
  49. ;;; * This is the Guile side of the Emacs interface                     *
  50. ;;; * Experimental hACK---the real version will be coming soon (almost) *
  51. ;;; *********************************************************************
  52.  
  53. ;;; {Session support for Emacs}
  54. ;;;
  55.  
  56. (define-module (ice-9 emacs)
  57.   :use-module (ice-9 debug)
  58.   :use-module (ice-9 threads)
  59.   :use-module (ice-9 session)
  60.   :no-backtrace)
  61.  
  62. (define emacs-escape-character #\sub)
  63.  
  64. (define emacs-output-port (current-output-port))
  65.  
  66. (define (make-emacs-command char)
  67.   (let ((cmd (list->string (list emacs-escape-character char))))
  68.     (lambda ()
  69.       (display cmd emacs-output-port))))
  70.  
  71. (define enter-input-wait  (make-emacs-command #\s))
  72. (define exit-input-wait   (make-emacs-command #\f))
  73. (define enter-read-character #\r)
  74. (define sending-error      (make-emacs-command #\F))
  75. (define sending-backtrace (make-emacs-command #\B))
  76. (define sending-result    (make-emacs-command #\x))
  77. (define end-of-text      (make-emacs-command #\.))
  78. (define no-stack      (make-emacs-command #\S))
  79. (define no-source      (make-emacs-command #\R))
  80.  
  81. ;; {Error handling}
  82. ;;
  83.  
  84. (add-hook! before-backtrace-hook sending-backtrace)
  85. (add-hook! after-backtrace-hook end-of-text)
  86. (add-hook! before-error-hook sending-error)
  87. (add-hook! after-error-hook end-of-text)
  88.  
  89. ;; {Repl}
  90. ;;
  91.  
  92. (set-current-error-port emacs-output-port)
  93.  
  94. (add-hook! before-read-hook
  95.        (lambda ()
  96.          (enter-input-wait)
  97.          (force-output emacs-output-port)))
  98.  
  99. (add-hook! after-read-hook
  100.        (lambda ()
  101.          (exit-input-wait)
  102.          (force-output emacs-output-port)))
  103.  
  104. ;;; {Misc.}
  105.  
  106. (define (make-emacs-load-port orig-port)
  107.   (letrec ((read-char-fn  (lambda args
  108.                 (let ((c (read-char orig-port)))
  109.                   (if (eq? c #\soh)
  110.                   (throw 'end-of-chunk)
  111.                   c)))))
  112.     
  113.     (make-soft-port
  114.      (vector #f #f #f
  115.          read-char-fn
  116.          (lambda () (close-port orig-port)))
  117.      "r")))
  118.  
  119. (set-current-input-port (make-emacs-load-port (current-input-port)))
  120.  
  121. (define (result-to-emacs exp)
  122.   (sending-result)
  123.   (write exp emacs-output-port)
  124.   (end-of-text)
  125.   (force-output emacs-output-port))
  126.  
  127. (define load-acknowledge (make-emacs-command #\l))
  128.  
  129. (define load-port (current-input-port))
  130.  
  131. (define (flush-line port)
  132.   (let loop ((c (read-char port)))
  133.     (if (not (eq? c #\nl))
  134.     (loop (read-char port)))))
  135.  
  136. (define whitespace-chars (list #\space #\tab #\nl #\np))
  137.  
  138. (define (flush-whitespace port)
  139.   (catch 'end-of-chunk
  140.      (lambda ()
  141.        (let loop ((c (read-char port)))
  142.          (cond ((eq? c the-eof-object)
  143.             (error "End of file while receiving Emacs data"))
  144.            ((memq c whitespace-chars) (loop (read-char port)))
  145.            ((eq? c #\;) (flush-line port) (loop (read-char port)))
  146.            (else (unread-char c port))))
  147.        #f)
  148.      (lambda args
  149.        (read-char port) ; Read final newline
  150.        #t)))
  151.  
  152. (define (emacs-load filename linum colnum module interactivep)
  153.   (set-port-filename! %%load-port filename)
  154.   (set-port-line! %%load-port linum)
  155.   (set-port-column! %%load-port colnum)
  156.   (lazy-catch #t
  157.           (lambda ()
  158.         (let loop ((endp (flush-whitespace %%load-port)))
  159.           (if (not endp)
  160.               (begin
  161.             (save-module-excursion
  162.              (lambda ()
  163.                (if module
  164.                    (set-current-module (resolve-module module #f)))
  165.                (let ((result
  166.                   (start-stack read-and-eval!
  167.                            (read-and-eval! %%load-port))))
  168.                  (if interactivep
  169.                  (result-to-emacs result)))))
  170.             (loop (flush-whitespace %%load-port)))
  171.               (begin
  172.             (load-acknowledge)))
  173.           (set-port-filename! %%load-port #f)))    ;reset port filename
  174.           (lambda (key . args)
  175.         (set-port-filename! %%load-port #f)
  176.         (cond ((eq? key 'end-of-chunk)
  177.                (fluid-set! the-last-stack #f)
  178.                (set! stack-saved? #t)
  179.                (scm-error 'misc-error
  180.                   #f
  181.                   "Incomplete expression"
  182.                   '()
  183.                   '()))
  184.               ((eq? key 'exit))
  185.               (else
  186.                (save-stack 2)
  187.                (catch 'end-of-chunk
  188.                   (lambda ()
  189.                 (let loop ()
  190.                   (read-char %%load-port)
  191.                   (loop)))
  192.                   (lambda args
  193.                 #f))
  194.                (apply throw key args))))))
  195.  
  196. (define (emacs-eval-request form)
  197.   (result-to-emacs (eval form (interaction-environment))))
  198.  
  199. ;;*fixme* Not necessary to use flags no-stack and no-source
  200. (define (get-frame-source frame)
  201.   (if (or (not (fluid-ref the-last-stack))
  202.       (>= frame (stack-length (fluid-ref the-last-stack))))
  203.       (begin
  204.     (no-stack)
  205.     #f)
  206.       (let* ((frame (stack-ref (fluid-ref the-last-stack)
  207.                    (frame-number->index frame)))
  208.          (source (frame-source frame)))
  209.     (or source
  210.         (begin (no-source)
  211.            #f)))))
  212.  
  213. (define (emacs-select-frame frame)
  214.   (let ((source (get-frame-source frame)))
  215.     (if source
  216.     (let ((fname (source-property source 'filename))
  217.           (line (source-property source 'line))
  218.           (column (source-property source 'column)))
  219.       (if (and fname line column)
  220.           (list fname line column)
  221.           (begin (no-source)
  222.              '())))
  223.     '())))
  224.  
  225. (define (object->string x . method)
  226.   (with-output-to-string
  227.     (lambda ()
  228.       ((if (null? method)
  229.        write
  230.        (car method))
  231.        x))))
  232.  
  233. (define (format template . rest)
  234.   (let loop ((chars (string->list template))
  235.          (result '())
  236.          (rest rest))
  237.     (cond ((null? chars) (list->string (reverse result)))
  238.       ((char=? (car chars) #\%)
  239.        (loop (cddr chars)
  240.          (append (reverse
  241.               (string->list
  242.                (case (cadr chars)
  243.                  ((#\S) (object->string (car rest)))
  244.                  ((#\s) (object->string (car rest) display)))))
  245.              result)
  246.          (cdr rest)))
  247.       (else (loop (cdr chars) (cons (car chars) result) rest)))))
  248.  
  249. (define (error-args->string args)
  250.   (let ((msg (apply format (caddr args) (cadddr args))))
  251.     (if (symbol? (cadr args))
  252.     (string-append (symbol->string (cadr args))
  253.                ": "
  254.                msg)
  255.     msg)))
  256.  
  257. (define (emacs-frame-eval frame form)
  258.   (let ((source (get-frame-source frame)))
  259.     (if source
  260.     (catch #t
  261.            (lambda ()
  262.          (list 'result
  263.                (object->string
  264.             (local-eval (with-input-from-string form read)
  265.                     (memoized-environment source)))))
  266.            (lambda args
  267.          (list (car args)
  268.                (error-args->string args))))
  269.     (begin
  270.       (no-source)
  271.       '()))))
  272.  
  273. (define (emacs-symdoc symbol)
  274.   (if (or (not (module-bound? (current-module) symbol))
  275.       (not (procedure? (eval symbol (interaction-environment)))))
  276.       'nil
  277.       (procedure-documentation (eval symbol (interaction-environment)))))
  278.  
  279. ;;; A fix to get the emacs interface to work together with the module system.
  280. ;;;
  281. (for-each (lambda (name value)
  282.         (module-define! the-root-module name value))
  283.       '(%%load-port
  284.         %%emacs-load
  285.         %%emacs-eval-request
  286.         %%emacs-select-frame
  287.         %%emacs-frame-eval
  288.         %%emacs-symdoc
  289.         %%apropos-internal)
  290.       (list load-port
  291.         emacs-load
  292.         emacs-eval-request
  293.         emacs-select-frame
  294.         emacs-frame-eval
  295.         emacs-symdoc
  296.         apropos-internal))
  297.